home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Merciful 2
/
Merciful - Disc 2.iso
/
software
/
h
/
highspeedpascalv2.0a.dms
/
highspeedpascalv2.0a.adf
/
HSPascal
/
AmigaDemos
/
Init.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-12-31
|
12KB
|
377 lines
{--------------------------------------------------------------------------
HighSpeed Pascal for the Amiga
ROUTINES FOR DEMO INITIALIZATION
Programmed by Martin Eskildsen 1991
Copyright (c) 1991 by D-House I ApS
All rights reserved
Version : Date (dd.mm.yy) : Comment
-----------------------------------
1.00 : 06.11.91 : First version
1.01 : 16.12.91 : System unit names updated
--------------------------------------------------------------------------}
unit Init;
INTERFACE
uses Exec, Intuition, Graphics, Amiga;
const
ScrWidth = 640; { Size of custom screen }
ScrHeight = 200; { Should not be changed! }
function PrepareEnvironment(s : string) : boolean;
{ Prepare an environment for the demo }
procedure CloseDown; { De-init environment }
procedure Inform(s : string); { Write message }
procedure Message(s : string); { Write message and wait for acknowledement }
procedure WaitMessageClose; { Wait for msg. window close gadget }
function Panic(condition : boolean; s : string) : boolean;
{ Write panic message s if condition is }
{ TRUE and return condition as result }
procedure WaitClose(var w : pWindow); { Wait for user to click window w's close gadget }
procedure EnableClose(var w : pWindow); { Enable Close messages }
procedure DisableClose(var w : pWindow);{ Disable Close messages }
procedure OpenOutputWindow; { Create a standard demo window }
procedure CloseOutputWindow; { Remove it again }
procedure ClearOutputWindow; { Clear work area }
function CStrConstPtr(s : string) : pointer;
{ This makes s a "C" string, allocates a chunck of heap large enough for s
to reside therein, puts s in the new memory and returns a pointer to it.
Please note that the memory is never released again in the program's
lifespan. This avoids global variables containing screen/window titles. }
function RetrieveStr(p : pointer) : string;
{ Pick a "C" string from memory pointed at by p and make it Pascal string }
function Max(a, b : integer) : integer;
function Min(a, b : integer) : integer;
procedure SwapMin(var a, b : integer); { Make sure a <= b }
function LegalPosition(x, y : integer) : boolean; { Is (x,y) inside output? }
function Binary(s : string) : integer; { Make binary value from s }
{ s can contain any character but only 0 and 1 are used for evauation }
PROCEDURE W(CH:CHAR);
var
BaseScreen : pScreen;
TopOffset : integer; { First raster line usable by demo }
OutputWinDef : tNewWindow; { Definition of output window }
{ The variable is set up in the }
{ unit but made global so the user can }
{ alter it before calling }
{ OpenOutputWindow. }
OutputWindow : pWindow; { The actual output window }
OutputTitle : String; { Output window's title }
WorkArea : record { Actual usable area in window }
minX, maxX,
minY, maxY : integer
end;
IMPLEMENTATION
PROCEDURE W(CH:CHAR); BEGIN WRITE(CH) END;
const
IRev = 0; { Required Intuition revision }
GRev = 0; { Required Graphics revision }
Detail = 0;
Block = 1;
var
MsgWindow : pWindow; { The message window }
FontInfo : tTextAttr;
procedure CloseEnvironment;
begin
CloseWindow(MsgWindow); { Remove the message window }
CloseScreen(BaseScreen); { and the screen }
CloseLibrary(pLibrary(IntuitionBase)); { Close Intuition }
CloseLibrary(pLibrary(GfxBase)) { and Graphics }
end;
function PrepareEnvironment(s : string) : boolean;
label 1; { Disaster termination point }
var
status : boolean; { TRUE = everything went ok }
BaseScreenDef : tNewScreen; { Record defining the custom screen }
MsgWindowDef : tNewWindow; { Record defining the message window }
procedure DefineStdOutputWindow;
begin
with OutputWinDef do begin
LeftEdge := 10;
TopEdge := TopOffset;
Width := ScrWidth - 2 * LeftEdge;
Height := ScrHeight - TopOffset - 5;
DetailPen := Detail;
BlockPen := Block;
Title := @OutputTitle[1];
Flags := WINDOWCLOSE or SMART_REFRESH or WINDOWDEPTH or NOCAREREFRESH;
IDCMPflags := CLOSEWINDOW_;
Type_ := CUSTOMSCREEN;
FirstGadget := NIL;
CheckMark := NIL;
Screen := BaseScreen;
BitMap := NIL;
MinWidth := Width;
MinHeight := Height;
MaxWidth := MinWidth;
MaxHeight := MaxHeight
end;
OutputTitle := 'Output'#0;
OutputWindow := NIL
end;
begin
status := FALSE;
TopOffset := 0;
IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library', IRev));
{ Note the typecast pIntuitionBase(... }
if Panic(IntuitionBase = NIL, 'intuition.library could not be opened') then goto 1;
GfxBase := pGfxBase(OpenLibrary('graphics.library', GRev));
if Panic(GfxBase = NIL, 'graphics.library could not be opened') then goto 1;
with FontInfo do begin
ta_Name := CStrConstPtr('topaz.font');
ta_YSize := TOPAZ_EIGHTY;
ta_Style := FS_NORMAL;
ta_Flags := FPF_ROMFONT
end;
with BaseScreenDef do begin
LeftEdge := 0; { MUST be 0! }
TopEdge := 0;
Width := ScrWidth;
Height := ScrHeight;
Depth := 2; { Two bit planes = four colors }
DetailPen := Detail; { Color for details }
BlockPen := Block; { and for blocks }
ViewModes := HIRES; { High resolution }
Type_ := CUSTOMSCREEN; { Note the underscore '_' }
Font := @FontInfo; { Use the normal Topaz font }
DefaultTitle := CStrConstPtr('HighSpeed Pascal for the Amiga! Copyright (c) 1991 by D-House I ApS');
Gadgets := NIL; { No gadgets }
CustomBitMap := NIL { No bitmap }
end;
BaseScreen := OpenScreen(@BaseScreenDef); { Note the @ operator }
if Panic(BaseScreen = NIL, 'Could not open demo screen') then begin
CloseLibrary(pLibrary(IntuitionBase)); { No screen! Close libs and }
CloseLibrary(pLibrary(GfxBase)); { get out of here! }
goto 1
end;
with MsgWindowDef do begin
LeftEdge := 10;
TopEdge := 15;
Width := ScrWidth - 2 * LeftEdge;
Height := 28;
DetailPen := Detail;
BlockPen := Block;
Title := CStrConstPtr('Messages. Use the Close gadget to accept/continue');
Flags := WINDOWCLOSE or { Add Close gadget and }
WINDOWDEPTH or { depth arrangement gadgets }
SMART_REFRESH or { Save window in RAM }
ACTIVATE or { Activate it }
NOCAREREFRESH; { Don't wanna hear of refreshes! }
IDCMPFlags := CLOSEWINDOW_; { But of user-clicks on Close }
Type_ := CUSTOMSCREEN; { Put window in custom screen }
FirstGadget := NIL; { No gadgets attached }
CheckMark := NIL; { Same checkmark as usual }
Screen := BaseScreen; { Use our own custom screen }
BitMap := NIL; { No bitmap }
MinWidth := Width; { Dummies as we can't resize }
MinHeight := Height; { this window }
MaxWidth := MinWidth;
MaxHeight := MinHeight
end;
MsgWindow := OpenWindow(@MsgWindowDef);
if Panic(MsgWindow = NIL, 'Can not open message window') then begin
CloseEnvironment;
goto 1
end;
DisableClose(MsgWindow); { See WINDOW1.PAS for explanation }
status := TRUE; { No Gurus! (yet...) Announce it to the world }
TopOffset := MsgWindowDef.TopEdge + { Top of window plus }
MsgWindowDef.Height + { window's height plus }
10; { a margin }
DefineStdOutputWindow;
Message('Welcome to the ' + s + ' Demo!');
1: { Where to go if the world turns against you }
PrepareEnvironment := status
end;
procedure CloseDown;
begin
if OutputWindow <> NIL then { <> NIL = window still on screen }
CloseOutputWindow; { so we close it }
Message('That''s all folks!');
CloseEnvironment
end;
procedure Inform(s : string);
begin
while length(s) < 73 do s := s + ' '; { Pad with spaces (simple, eh?) }
s := copy(s, 1, 73); { Truncate string to 73 chars }
with MsgWindow^ do begin
Move_(RPort, 20, 20); { Put text at (20,20) }
Text_(RPort, s, length(s)) { Output it }
end
end;
procedure WaitClose(var w : pWindow); { Wait for the user to }
var dummy : integer; { click the Close gadget }
begin { in window w }
EnableClose(w);
dummy := Wait(BitMask(w^.UserPort^.MP_SIGBIT));
DisableClose(w)
end;
procedure EnableClose(var w : pWindow);
begin
with w^ do IDCMPflags := IDCMPflags or CLOSEWINDOW_
end;
procedure DisableClose(var w : pWindow);
begin
with w^ do IDCMPflags := IDCMPflags and not CLOSEWINDOW_
end;
procedure Message(s : string);
begin
Inform(s); { Output message }
WaitClose(MsgWindow) { Wait for Close }
end;
procedure WaitMessageClose;
begin
WaitClose(MsgWindow)
end;
function Panic(condition : boolean; s : string) : boolean;
begin
if condition then Message('Demo problem: ' + s + ' - terminating soon.');
Panic := condition
end;
procedure OpenOutputWindow;
begin
OutputTitle := OutputTitle + #0; { Just to be sure }
OutputWinDef.Title := @OutputTitle[1];
OutputWindow := OpenWindow(@OutputWinDef);
if Panic(OutputWindow = NIL, 'Can''t open output window') then begin
CloseDown;
halt(0)
end;
SetApen(OutputWindow^.RPort, 3);
with OutputWindow^, WorkArea do begin
minX := BorderLeft;
minY := BorderTop;
maxX := Width - BorderRight;
maxY := Height - BorderBottom
end
end;
procedure CloseOutputWindow;
begin
CloseWindow(OutputWindow);
OutputWindow := NIL
end;
procedure ClearOutputWindow;
begin
with WorkArea, OutputWindow^ do begin
SetAPen(RPort, 0);
RectFill(RPort, minX, minY, maxX, maxY);
SetAPen(RPort, 3)
end
end;
function CStrConstPtr(s : string) : pointer;
type a = packed array [0..255] of char;
var p : ^a;
begin
s := s + #0; { Make "C" string }
getmem(p, length(s)); { Get some mem for it }
move(s[1], p^, length(s)); { Move s into newly alloc'd mem }
CStrConstPtr := p { Return the pointer }
end;
function RetrieveStr(p : pointer) : string;
type
a = packed array [0..255] of char;
var
i : integer;
sptr : ^a;
s : string;
begin
sptr := p;
s := '';
i := 0;
while sptr^[i] <> #0 do begin
s := s + sptr^[i];
inc(i)
end;
RetrieveStr := s
end;
function Max(a, b : integer) : integer;
begin
if a > b then Max := a else Max := b
end;
function Min(a, b : integer) : integer;
begin
if a < b then Min := a else Min := b
end;
procedure SwapMin(var a, b : integer);
var t : integer;
begin
if a > b then begin
t := a;
a := b;
b := t
end
end;
function LegalPosition(x, y : integer) : boolean;
begin
with WorkArea do LegalPosition := (x >= minX) and (x <= maxX) and
(y >= minY) and (y <= maxY)
end;
function Binary(s : string) : integer;
var i, n : integer;
begin
n := 0;
for i := 1 to length(s) do
if s[i] in ['0', '1'] then n := n*2 + ord(s[i]) - ord('0');
Binary := n
end;
end.